home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / PalTool.cls < prev    next >
Text File  |  1997-06-14  |  12KB  |  369 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "GPalTool"
  6. Attribute VB_GlobalNameSpace = True
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum ECycleDirection
  13.     ecdCycleLeft
  14.     ecdCycleRight
  15.     ecdCycleIn
  16.     ecdCycleOut
  17. End Enum
  18.  
  19. Public Enum EErrorPalTool
  20.     eeBasePalTool = 13540   ' PalTool
  21. End Enum
  22.  
  23. Sub DrawPalette(cvsDst As Object, hPal As Long, _
  24.                 Optional ByVal dx As Long, Optional ByVal dy As Long, _
  25.                 Optional ByVal x As Long, Optional ByVal y As Long)
  26.     If dx = 0 Then dx = cvsDst.ScaleWidth
  27.     If dy = 0 Then dy = cvsDst.ScaleHeight
  28.     If hPal = 0 Then Exit Sub
  29.     
  30.     Dim c As Long, cPal As Integer, ape() As PALETTEENTRY
  31.     ' Get the size of the palette and dimension the array to it
  32.     cPal = PalSize(hPal)
  33.     ReDim ape(0 To cPal - 1) As PALETTEENTRY
  34.     ' Fill the array with palette colors
  35.     c = GetPaletteEntries(hPal, 0&, cPal, ape(0))
  36.     BugAssert c = cPal
  37.     Dim i As Long, dxBar As Long, clr As Long
  38.     ' Draw the palette colors as bars proportional to size of canvas
  39.     dxBar = dx / cPal
  40.     For i = 0 To cPal - 2
  41.         x = i * dxBar
  42.         cvsDst.Line (x, y)-(x + dxBar, y + dy), _
  43.                     PaletteColorFromEntry(ape(i)), BF
  44.     Next
  45. End Sub
  46.  
  47. ' Attempt to get the palette colors of a bitmap from its handle
  48. Function GetBitmapPalette(ByVal hBmp As Long, _
  49.                           Optional ByVal hDC As Long = hInvalid) As Long
  50.     Dim bmp As BITMAP, bmpi As BITMAPINFO256
  51.     Dim cClrBits As Integer, f As Long
  52.  
  53.     ' Retrieve bitmap color format, width, and height
  54.     f = GetObjectBitmap(hBmp, LenB(bmp), bmp)
  55.  
  56.     ' Convert the color format to a count of bits
  57.     cClrBits = bmp.bmPlanes * bmp.bmBitsPixel
  58.  
  59.     ' Like VB, we only return 256-color palettes
  60.     If cClrBits <> 8 Then Exit Function
  61.  
  62.     ' Initialize the fields in the BITMAPINFOHEADER structure.
  63.     bmpi.bmiHeader.biSize = LenB(bmpi.bmiHeader)
  64.     bmpi.bmiHeader.biWidth = bmp.bmWidth
  65.     bmpi.bmiHeader.biHeight = bmp.bmHeight
  66.     bmpi.bmiHeader.biPlanes = bmp.bmPlanes
  67.     bmpi.bmiHeader.biBitCount = bmp.bmBitsPixel
  68.     bmpi.bmiHeader.biCompression = BI_RGB
  69.     bmpi.bmiHeader.biClrUsed = 0
  70.     bmpi.bmiHeader.biClrImportant = 0
  71.     ' Compute the number of bytes in the array of color
  72.     ' indices and store the result in SizeImage field
  73.     Dim cSizeImage As Long
  74.     cSizeImage = (bmp.bmWidth + 7) / 8 * bmp.bmHeight * cClrBits
  75.     bmpi.bmiHeader.biSizeImage = cSizeImage
  76.  
  77.     ' Retrieve the color table (RGBQUAD array) and the bits
  78.     ' (array of palette indices) from the DIB
  79.     Dim hDCTmp As Long, cColors As Integer
  80.     If hDC = hInvalid Then
  81.         hDCTmp = GetDC(0)
  82.     Else
  83.         hDCTmp = hDC
  84.     End If
  85.     f = GetDIBits(hDCTmp, hBmp, 0, bmp.bmHeight, ByVal 0, _
  86.                   bmpi, DIB_RGB_COLORS)
  87.     ' Free the DC
  88.     If hDC = hInvalid Then f = ReleaseDC(0, hDCTmp)
  89.                              
  90.     Dim lpal As LOGPALETTE256, i As Long, c As Long
  91.     cColors = bmpi.bmiHeader.biClrUsed
  92.     ' Like VB, we only return 256-color palettes
  93.     If cColors = 0 Then cColors = 256
  94.       
  95.     ' RGBQUAD used by GetDIBColorTable has different format from PALETTEENTRY
  96.     ' used by LOGPALETTE, so can't use CopyMemory
  97.     For i = 0 To cColors - 1
  98.         ' Skip black colors
  99.         If i >= 1 And i < cColors - 1 Then
  100.             If bmpi.bmiColors(i).rgbRed = 0 And _
  101.                bmpi.bmiColors(i).rgbGreen = 0 And _
  102.                bmpi.bmiColors(i).rgbBlue = 0 Then
  103.                 GoTo ContinueFor
  104.             End If
  105.         End If
  106.         ' Copy and translate colors
  107.         lpal.palPalEntry(i).peRed = bmpi.bmiColors(i).rgbRed
  108.         lpal.palPalEntry(i).peGreen = bmpi.bmiColors(i).rgbGreen
  109.         lpal.palPalEntry(i).peBlue = bmpi.bmiColors(i).rgbBlue
  110.         lpal.palPalEntry(i).peFlags = 0
  111.         c = c + 1
  112. ContinueFor:
  113.     Next
  114.     lpal.palNumEntries = IIf(c Mod 2, c - 1, c)
  115.     Debug.Print "Colors: " & lpal.palNumEntries
  116.     lpal.palVersion = &H300
  117.  
  118.     ' Create and return the palette
  119.     GetBitmapPalette = CreatePalette(lpal)
  120.  
  121. End Function
  122.  
  123. ' Load a bitmap and its palette from a resource
  124. Function LoadBitmapPalette(ByVal hMod As Long, vResource As Variant, _
  125.                            hPal As Long) As Long
  126.                            
  127.     ' Make null in case of failure
  128.     Dim hBmp As Long
  129.     hPal = hNull
  130.     
  131.     Dim hRes As Long, hmemRes As Long, cRes As Long
  132.     Dim pRes As Long, abRes() As Byte
  133.     If VarType(vResource) = vbString Then
  134.         hBmp = LoadImage(hMod, CStr(vResource), IMAGE_BITMAP, _
  135.                          0, 0, LR_CREATEDIBSECTION)
  136.         hRes = FindResourceStrId(hMod, CStr(vResource), RT_BITMAP)
  137.         
  138.     Else
  139.         hBmp = LoadImageID(hMod, CLng(vResource), IMAGE_BITMAP, _
  140.                            0, 0, LR_CREATEDIBSECTION)
  141.         hRes = FindResourceIdId(hMod, CLng(vResource), RT_BITMAP)
  142.     End If
  143.     ' If bitmap found, return it
  144.     If hBmp = hNull Then Exit Function
  145.     LoadBitmapPalette = hBmp
  146.     BugAssert hRes <> hNull     ' Shouldn't fail here
  147.     ' Allocate memory block, and get its size
  148.     hmemRes = LoadResource(hMod, hRes)
  149.     cRes = SizeofResource(hMod, hRes)
  150.     ' Lock it to get pointer
  151.     pRes = LockResource(hmemRes)
  152.     
  153.     Dim bmpi As BITMAPINFO256
  154.     If cRes > LenB(bmpi) Then cRes = LenB(bmpi)
  155.     ' Copy memory block to array
  156.     CopyMemory bmpi, ByVal pRes, cRes
  157.     ' Free resource (no need to unlock)
  158.     Call FreeResource(hmemRes)
  159.     
  160.     Dim lpal As LOGPALETTE256, cColors As Long, cBits As Long, i As Long
  161.     cColors = bmpi.bmiHeader.biClrUsed
  162.     cBits = bmpi.bmiHeader.biBitCount
  163.     ' Like VB, we only return 256-color palettes
  164.     If cBits <> 8 Then Exit Function
  165.     If cColors = 0 Then cColors = 256
  166.  
  167.     ' RGBQUAD in BITMAPINFO has different format from PALETTEENTRY
  168.     ' in LOGPALETTE, so can't use CopyMemory
  169.     For i = 0 To cColors - 1
  170.         ' Copy and translate colors
  171.         lpal.palPalEntry(i).peRed = bmpi.bmiColors(i).rgbRed
  172.         lpal.palPalEntry(i).peGreen = bmpi.bmiColors(i).rgbGreen
  173.         lpal.palPalEntry(i).peBlue = bmpi.bmiColors(i).rgbBlue
  174.         lpal.palPalEntry(i).peFlags = 0
  175.     Next
  176.     lpal.palNumEntries = cColors
  177.     lpal.palVersion = &H300
  178.  
  179.     ' Create and return the palette through a reference
  180.     hPal = CreatePalette(lpal)
  181.  
  182. End Function
  183.  
  184. Function PalSize(ByVal hPal As Long) As Integer
  185.     Dim c As Integer, res As Long
  186.     res = GetObjectPaletteEntries(hPal, 2, c)
  187.     PalSize = c
  188. End Function
  189.  
  190. Private Function PaletteColorFromEntry(pe As PALETTEENTRY) As OLE_COLOR
  191.     ' Copy color bytes, ignore flag byte
  192.     CopyMemory PaletteColorFromEntry, pe, 3
  193. End Function
  194.  
  195. Private Sub PaletteColorToEntry(pe As PALETTEENTRY, ByVal clr As OLE_COLOR)
  196.     ' Copy color bytes, ignore flag byte
  197.     CopyMemory pe, clr, 3
  198. End Sub
  199.  
  200. ' Potentially the most efficient palette is an identity palette--one that is
  201. ' the same size as the system palette and that has the same system colors in its
  202. ' first and last entries. The user-defined colors go in the middle. This function
  203. ' takes a normal palette and returns the handle of an equivalent identity palette.
  204. ' It also returns the position of the first non-system color.
  205. Function MakeIdentityPalette(ByVal hPal As Long, iFirst As Long) As Long
  206. Dim logpal As LOGPALETTE256
  207. With logpal
  208.     
  209.     Dim iLast As Long, hDC As Long, cStatic As Long, cPal As Long
  210.     hDC = GetDC(hNull)
  211.     ' Get the size of the palette and dimension the array to it
  212.     .palVersion = &H300
  213.     .palNumEntries = 256
  214.     cPal = PalSize(hPal)
  215.     
  216.     ' We only deal with SYSPAL_STATIC mode (the most common)
  217.     If GetSystemPaletteUse(hDC) <> SYSPAL_STATIC Then Exit Function
  218.     
  219.     ' Get the twenty static colors into array and then
  220.     ' fill the empty spaces with the color table
  221.     cStatic = GetDeviceCaps(hDC, NUMCOLORS)
  222.     ' Too many colors for identity palette
  223.     If cPal > 256 - cStatic Then Exit Function
  224.     
  225.     ' Get the system palette into the palette
  226.     Dim i As Long, f As Long
  227.     f = GetSystemPaletteEntries(hDC, 0, 256, .palPalEntry(0))
  228.     iFirst = (cStatic \ 2)
  229.     iLast = iFirst + cPal
  230.     
  231.     ' Fill the middle of the array with palette colors
  232.     f = GetPaletteEntries(hPal, iFirst, cPal, .palPalEntry(iFirst))
  233.     
  234.     ' Set the peFlags of the lower static colors to zero
  235.     For i = 0 To iFirst - 1
  236.         .palPalEntry(i).peFlags = 0
  237.     Next
  238.     
  239.     ' Mark our entries as PC_RESERVED
  240.     For i = i To iFirst + cPal
  241.         .palPalEntry(i).peFlags = PC_RESERVED
  242.     Next
  243.     
  244.     ' Mark any other as black PC_RESERVED
  245.     For i = i To 255 - (cStatic \ 2)
  246.         .palPalEntry(i).peFlags = PC_RESERVED
  247.         .palPalEntry(i).peBlue = 0
  248.         .palPalEntry(i).peGreen = 0
  249.         .palPalEntry(i).peRed = 0
  250.     Next
  251.     
  252.     ' Set the peFlags of the upper static colors to zero
  253.     For i = i To 255
  254.         .palPalEntry(i).peFlags = 0
  255.     Next
  256.       
  257.     ReleaseDC hNull, hDC
  258.     
  259.     ' Create the palette
  260.     MakeIdentityPalette = CreatePalette(logpal)
  261. End With
  262. End Function
  263.  
  264. ' Returns handle of a new palette identical to one passed as a parameter
  265. Function DuplicatePalette(ByVal hPal As Long) As Long
  266.     
  267.     Dim f As Long, hDC As Long, cPal As Long
  268.     hDC = GetDC(hNull)
  269.     Dim logpal As LOGPALETTE256
  270.     With logpal
  271.         ' Get the size of the palette and dimension the array to it
  272.         cPal = PalSize(hPal)
  273.         .palVersion = &H300
  274.         .palNumEntries = cPal
  275.        
  276.         ' Fill the logical palette array with palette colors
  277.         f = GetPaletteEntries(hPal, 0, cPal, .palPalEntry(0))
  278.         
  279.         ReleaseDC hNull, hDC
  280.         
  281.         ' Create the palette
  282.         DuplicatePalette = CreatePalette(logpal)
  283.     End With
  284. End Function
  285.  
  286. ' Rotates an array of palette colors initialized by the CPalette class
  287. Sub RotatePaletteArray(aColors() As OLE_COLOR, ByVal ecdA As ECycleDirection)
  288.     Dim i As Long, clrT As OLE_COLOR, iLo As Long, iHi As Long
  289.     iLo = LBound(aColors): iHi = UBound(aColors)
  290.     
  291.     Select Case ecdA
  292.     Case ecdCycleLeft
  293.         ' Left to right
  294.         clrT = aColors(iLo)
  295.         For i = iLo To iHi - 1
  296.             aColors(i) = aColors(i + 1)
  297.         Next
  298.         aColors(iHi) = clrT
  299.     Case ecdCycleRight
  300.         ' Right to left
  301.         clrT = aColors(iHi)
  302.         For i = iHi To iLo + 1 Step -1
  303.             aColors(i) = aColors(i - 1)
  304.         Next
  305.         aColors(iLo) = clrT
  306.     Case ecdCycleIn
  307.         ' In to the middle
  308.         iHi = iHi \ 2
  309.         ' Right to left
  310.         clrT = aColors(iHi)
  311.         For i = iHi To iLo + 1 Step -1
  312.             aColors(i) = aColors(i - 1)
  313.         Next
  314.         aColors(iLo) = clrT
  315.         ' Reset bounds
  316.         iLo = iHi + 1
  317.         iHi = UBound(aColors)
  318.         ' Left to right
  319.         clrT = aColors(iLo)
  320.         For i = iLo To iHi - 1
  321.             aColors(i) = aColors(i + 1)
  322.         Next
  323.         aColors(iHi) = clrT
  324.         
  325.     Case ecdCycleOut
  326.         ' Out from the middle
  327.         iHi = iHi \ 2
  328.         ' Left to right
  329.         clrT = aColors(iLo)
  330.         For i = iLo To iHi - 1
  331.             aColors(i) = aColors(i + 1)
  332.         Next
  333.         aColors(iHi) = clrT
  334.         ' Reset bounds
  335.         iLo = iHi + 1
  336.         iHi = UBound(aColors)
  337.         ' Right to left
  338.         clrT = aColors(iHi)
  339.         For i = iHi To iLo + 1 Step -1
  340.             aColors(i) = aColors(i - 1)
  341.         Next
  342.         aColors(iLo) = clrT
  343.     End Select
  344. End Sub
  345.  
  346. ' Add more palette manipulation functions here--start with palette fade in
  347. ' and fade out
  348.  
  349. #If fComponent = 0 Then
  350. Private Sub ErrRaise(e As Long)
  351.     Dim sText As String, sSource As String
  352.     If e > 1000 Then
  353.         sSource = App.ExeName & ".PalTool"
  354.         Select Case e
  355.         Case eeBasePalTool
  356.             BugAssert True
  357.        ' Case ee...
  358.        '     Add additional errors
  359.         End Select
  360.         Err.Raise COMError(e), sSource, sText
  361.     Else
  362.         ' Raise standard Visual Basic error
  363.         sSource = App.ExeName & ".VBError"
  364.         Err.Raise e, sSource
  365.     End If
  366. End Sub
  367. #End If
  368.  
  369.